home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0391B.ZIP / NEARMISS.ARC / NEARMISS.INC next >
Text File  |  1986-06-23  |  3KB  |  110 lines
  1. {
  2. This function uses a modified version of the soundex algorithm as implemented
  3. by Glen F. Marshall.  The changes to Marshall's algorithm are that the
  4. end result is an integer rather than a string, and the algorithm simply
  5. ignores non-alphabet characters.
  6.  
  7. To this, the NearMiss algorithm is added, which parses an input string
  8. and uses spaces as delimeters to break the string up into substrings, which it
  9. then sends to the soundex1 algorithm.  The results are summed into the
  10. resulting real value, and returned to the calling program.  In this manner,
  11. you can get a "close enough" match on very long strings, where minor spelling
  12. errors between strings can be accounted for by subtracting one NearMiss
  13. value from the other, and determining the size of the mis-match.
  14. In this manner you can determine how close a near-miss can come to be
  15. considered a match.
  16.  
  17. Written and placed in the public domain by
  18. John Sims
  19. 1643 Calle Lindero
  20. Lompoc, CA  93436
  21.  
  22. Use, modify, or do with it what you will.... enjoy!
  23. }
  24.  
  25.  
  26.  
  27. Function NearMiss(input_string : anystr) : Real;
  28. var
  29. Beginning, Ending, Whoa : Integer;
  30. Temp : Real;
  31. SCode : anystr;
  32.  
  33.  
  34. function soundex1(var name: anystr): integer;
  35.   var
  36.     work: array[0..3] of char;
  37.     code: char;
  38.     counter, i,j: integer;
  39.  
  40.   function encode(var c: char): char;
  41.     var
  42.       r: char;
  43.     begin
  44.       case upcase(c) of
  45.         'B','F','P','V':                 r := '1';
  46.         'C','G','J','K','Q','S','X','Z': r := '2';
  47.         'D','T':                         r := '3';
  48.         'L':                             r := '4';
  49.         'M','N':                         r := '5';
  50.         'R':                             r := '6';
  51.         'A','E','I','O','U','Y':         r := '7';
  52.         'H','W':                         r := '8';
  53.         else                             r := ' ';
  54.       end;
  55.       encode := r;
  56.     end; {encode}
  57.   begin
  58.     if length(name) > 0
  59.       then work[0] := encode(name[1])
  60.       else work[0] := ' ';
  61.     if work[0] <> ' '
  62.       then i := 2
  63.       else i := length(name) + 1;
  64.     j := 0;  counter := 0;
  65.     while (i <= length(name)) and (j < 3) do
  66.     begin
  67.       code := encode(name[i]);
  68.       if code in ['1'..'6']
  69.         then if work[j] <> code
  70.                then begin
  71.                       counter := counter + 1;
  72.                       j := j+1;
  73.                       work[j] := code;
  74.                     end;
  75.       i := i + 1;
  76.     end;
  77.     for j := j+1 to 3 do work[j] := '0';
  78.     Val(work, counter, j);
  79.     Soundex1 := counter;
  80.   end; {soundex}
  81.  
  82. Procedure FindNextBlank;
  83. begin
  84. While (Input_String[Ending] <> ' ') and (Ending <= Whoa) do
  85.       Ending := Ending + 1;
  86. End;
  87.  
  88. Procedure FindNextChar;
  89. begin
  90. While(Input_String[Beginning] = ' ') and (Beginning <= Whoa) do
  91.      Beginning := Beginning + 1;
  92. If Beginning > Whoa then Beginning := Whoa
  93. else Ending := Beginning;
  94. End;
  95.  
  96. begin
  97. Beginning := 1;
  98. Ending := 1;
  99. Whoa := Length(Input_String);
  100. Temp := 0.0;
  101. While Beginning <= Whoa do
  102. begin
  103.   FindNextChar;
  104.   FindNextBlank;
  105.   SCode := Copy(Input_String, Beginning, (Ending - Beginning) + 1);
  106.   Temp := Temp + Soundex1(SCode);
  107.   Beginning := Ending + 1;
  108. end;
  109. NearMiss := Temp;
  110. End;